home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-03
/
qb4libm.zip
/
FASTQLB.BAS
< prev
next >
Wrap
BASIC Source File
|
1990-10-05
|
45KB
|
1,099 lines
'╔═════╡ FASTQLB.BAS - .QLB maker utility (enhanced) for BASIC programs ╞════╗
'║The original utility was named MAKEQLB and distributed by Crescent Software║
'║ Enhancements by David A. Violette, 12 Michaud Ave, Lewiston ME 04240 ║
'║ 207+783-6171 (eves). CompuServe 76456,1602 12 Aug 90 ║
'║ ║
'║ I have changed this program so that the file Objects.obj is named ║
'║ EXTERNAL.OBJ, and the file is retained instead of KILLed. By including ║
'║ EXTERNAL.OBJ in the LINK response file, a separate .LIB is not needed, ║
'║ since the external objects are already referenced in EXTERNAL.OBJ, and ║
'║ the program can be compiled and linked from the command line using the ║
'║ response file. This change allows easy and smallest .QLB but adds easy ║
'║ command line compilation/link using MAKE or NMAKE. See SUB MakeObj as ║
'║ well as this main module. ║
'║ ║
'║ FASTQLB may be invoked from the command line in one of several options: ║
'║ ║
'║ (1) FASTQLB prog.BAS,prog.QLB,prog.LST,PRO7 progUITB DTFMTER FINANCER,_ ║
'║ QBXQLB; ║
'║ ║
'║ (2) FASTQLB prog.LST,prog.QLB,prog.LST,PRO7 progUITB DTFMTER FINANCER,_ ║
'║ QBXQLB; ║
'║ ║
'║ (3) FASTQLB @response.ext ║
'║ ║
'║ prog is the name of the program. PRO7 is Crescent Software's QuickPak ║
'║ Professional library for BC7; this is searched for routines I might ║
'║ use in prog. ║
'║ ║
'║ DTFTMTER and FINANCER are libraries supplied by Microsoft with BC7 - ║
'║ these are searched when I use routines from them. ║
'║ ║
'║ progUITB started as the UITBEFR library supplied by Microsoft with ║
'║ BC7, but I have modified several of the routines for use in prog and ║
'║ built this special library. ║
'║ ║
'║ QBXQLB is the link library supplied by Microsoft with BC7. Change ║
'║ this to match the compiler you are using (eg: BQLB45.LIB). ║
'║ ║
'║ The first option will scan the source file given as the first parameter, ║
'║ plus any other module names listed in a prog.MAK file if present, to find ║
'║ the required routines. ║
'║ ║
'║ The second option will get the names of the routines by reading a ║
'║ prog.LST file. MAKEQLB (and FASTQLB) will create the prog.LST file when ║
'║ the first option is used, but you may manually edit this file to add or ║
'║ delete names of routines directly. Using prog.LST will greatly speed up ║
'║ processing the QLB since MAKEQLB (and FASTQLB) won't have to scan all ║
'║ the source files. ║
'║ ║
'║ The third option allows use of a response file to shorten the command ║
'║ line. The response file name is given immediately after the "@", and the ║
'║ response file contains the items required on the command line, given in ║
'║ the same way they would on a command line. The five parameters are ║
'║ described in Crescent's intro below (copied from their MAKEQLB.BAS ║
'║ module). I use two versions of the response file - one with prog.BAS as ║
'║ the source file name, and one with prog.LST as the source file name. The ║
'║ first will act as option (1), the second as (2). ║
'║ ║
'║ An example response file for option (1) operation might be as follows: ║
'║ ║
'║ prog.BAS,prog.QLB,prog.LST,PRO7 progUITB DTFMTER FINANCER,+ ║
'║ QBXQLB; ║
'║ ║
'║ An example response file for option (2) operation might be as follows: ║
'║ ║
'║ prog.LST,prog.QLB,prog.LST,PRO7 progUITB DTFMTER FINANCER,QBXQLB; ║
'║ ║
'║ The response file must have the parameters separated by commas and spaces ║
'║ as shown. If MAKEQLB (and FASTQLB) find a "+" it is replaced with a " " ║
'║ and the next line is appended. Essentially, the response file replaces ║
'║ command line parameters and allows longer lines to be edited using the + ║
'║ as a continuation symbol. ║
'║ ║
'║ A major advantage in using FASTQLB instead of MAKEQLB is that the file ║
'║ EXTERNAL.OBJ is saved for use in LINKing. This avoids having to build a ║
'║ separate prog.LIB library as well as the prog.QLB, because EXTERNAL.OBJ ║
'║ can be used to identify the external routines to be pulled from other ║
'║ libraries. This option is only available when you compile and link from ║
'║ the command line, however. ║
'║ ║
'║ To use EXTERNAL.OBJ, simply include it in your list of object files to ║
'║ LINK. I prefer to use a LINK response file, and I also use the MAKE ║
'║ utility with a companion description file. The MAKE prog.DES file might ║
'║ look like this: ║
'║ ║
'║ prog.obj: prog.bas ║
'║ bc prog /d/o/w/ah/fs; ║
'║ ║
'║ progmod1.obj: progmod1.bas ║
'║ bc progmod1 /d/o/w/ah/fs; ║
'║ ║
'║ progmod2.obj: progmod2.bas ║
'║ bc progmod2 /d/o/w/ah/fs; ║
'║ ║
'║ progmod3.obj: progmod3.bas ║
'║ bc progmod3 /d/o/w/ah/fs; ║
'║ ║
'║ progmod4.obj: progmod4.bas ║
'║ bc progmod4 /d/o/w/ah/fs; ║
'║ ║
'║ prog.exe: prog.obj progmod1.obj progmod2.obj progmod3.obj progmod4.obj ║
'║ link @prog.rsp ║
'║ ║
'║ The link response file prog.rsp might look like this: ║
'║ ║
'║ prog progmod1 + progmod2 + (progmod3) + (progmod4) + EXTERNAL.OBJ ║
'║ prog ║
'║ prog ║
'║ PRO7.LIB + progUITB.LIB + DTFMTER.LIB + FINANCER.LIB ║
'║ ║
'║ I have also added a feature that writes the unreferenced items to a file ║
'║ for each module, where the filename is modulename.UNR. This aids in ║
'║ cleaning up the modules. See SUB ReadSource. ║
'║ ║
'║ I have added a variable LibDir$ which uses any LIB environment variable ║
'║ to find the necessary libraries. See main module. ║
'║ ║
'╚═══════════════════════════════════════════════════════════════════════════╝
'┌─────────┤ MAKEQLB.BAS - .QLB maker utility for BASIC programs ├───────────┐
'│ │
'│Copyright (c) 1988, 1989 Crescent Software │
'│by Don Malin and Chris May with user input enhancements by Ken White │
'│Notes: │
'│ Source files must be saved in Text format. │
'│ │
'│ Five parameters are required for this program -- one or more main │
'│ program names, the new .QLB file name, a list file name (NUL for no │
'│ list), one or more library names from which to extract the needed │
'│ routines, and the BQLB## support library. As with LIB and LINK, a │
'│ semicolon (;) can be used to force MAKEQLB to use its defaults. │
'│ │
'│ The program will check for routines that were declared but never │
'│ used or BASIC procedures that were defined but never used. │
'│ Declared unreferenced routines will not be added to the new Quick │
'│ Library. │
'│ │
'│ If a list file (.LST) is given in place of the source file name, │
'│ the program will make the quick library from the list instead of │
'│ searching the source files for external references. │
'│ │
'│MAKEQLB basicprogram1 [Basicprogram2], quicklib[.qlb], listfile[.lst],_ │
'│ library[.lib] [library2[.lib], [bqlb##][;] │
'│ │
'│Compile and Link as follows: │
'│ BC makeqlb /ah /s [/fpa] /o; │
'│ LINK /e/noe makeqlb [nocom] [nolpt] [smallerr],,,pro; │
'│ │
'│ [] = optional items. "/fpa" and "smallerr" are available with │
'│ BASCOM 6, "no" object files may be included with your compiler. │
'│ │
'└───────────────────────────────────────────────────────────────────────────┘
DEFINT A-Z
'~~~~~ Define Constants
CONST BQLB$ = "QBXQLB.LIB" 'Default BASIC link library (BC 7)
CONST BASProc = -1 'Flag for BASIC procedures
CONST RefedProc = -2 'Flag for referenced procedures
CONST MaxProcs = 300 'Maximum number of procedures
CONST ProcLen2 = 40 'Maximum length for a procedure name
CONST ProcLen = 30 'Maximum length for module level
' procedure names
' Must be a power of 2 minus 2
' [ie. 30 = (2 ^ 5) - 2]
' because the TYPE below is used to
' DIM a huge array whose size could
' span multiple segments.
'~~~~~ Define TYPEs for procedure Info
TYPE ModProcs 'Module procedure information
ProcName AS STRING * ProcLen 'Procedure name
Count AS INTEGER 'Number of references in module
END TYPE
TYPE ProcInfo 'Procedure information for program
ProcName AS STRING * ProcLen2 'Procedure name
AliasName AS STRING * ProcLen2 'ALIAS'ed name
BasFlag AS INTEGER 'Flag field for BASIC procedure
Refed AS INTEGER 'Flag field shows referenced proc.
END TYPE
'~~~~~ Declare routines
DECLARE FUNCTION Blanks% (Strng$)
DECLARE FUNCTION CheckSum% (Strg$)
DECLARE FUNCTION Exist% (FileName$)
DECLARE FUNCTION NoPath$ (FileName$)
DECLARE FUNCTION NoXtn$ (FileName$)
DECLARE FUNCTION Null% (Text$)
DECLARE FUNCTION QPLen% (Text$)
DECLARE FUNCTION UserInp$ (NoSemi, Prompt$, Default$)
DECLARE FUNCTION Valid% (FileName$)
DECLARE SUB CheckName (FileName$)
DECLARE SUB FatalErr (Message$)
DECLARE SUB FindT (SEG Element AS ANY, TypeWidth, NumEls, Search$)
DECLARE SUB GetParms (FileName$, NewLib$, LstFile$, InpLibs$, BASLib$)
DECLARE SUB MakeObj (Subs, Procs() AS ProcInfo, LstFile$)
DECLARE SUB QPrint0 (Text$, Clr)
DECLARE SUB ReadSource (FileName$, Procs() AS ProcInfo, Subs)
DECLARE SUB SortT (SEG Element AS ANY, NumEls, Dir, TypeWidth, Offset, FieldWidth)
DECLARE SUB SrchPath (FileName$, Paths$, NotFound)
'~~~~~ Dim Procedure information array
DIM Procs(1 TO MaxProcs) AS ProcInfo
DIM SHARED ObjName$, RspName$, LibDir$
ObjName$ = ENVIRON$("TMP") + "External.obj" 'Saved Object file
RspName$ = ENVIRON$("TMP") + "DonMalin.rsp" 'Temporary response file for LINK
LibDir$ = ENVIRON$("LIB") + "\"
OtherObjName$ = ""
'~~~~~ Print Banner
PRINT
PRINT "Quick-Library Maker Utility Version 1.03"
PRINT "Copyright (c) 1988, 1989 Crescent Software"
PRINT "FASTQLB has modifications by David A. Violette, CompuServe 76456,1602."
PRINT "For personal use only; Crescent Software still owns the Copyright."
PRINT "Modified version made available by permission from Crescent Software."
PRINT
'~~~~~ Get input parameters from COMMAND$ or by prompting the User
GetParms FileName$, NewLib$, LstFile$, InpLibs$, BASLib$
Subs = 0 'Init. number of procs.
'~~~~~ Read each Main Module or List file specified
look = 1
DO
Spac = INSTR(look, FileName$, " ")
IF Spac = 0 THEN Spac = QPLen%(FileName$) + 1
SourceName$ = LTRIM$(MID$(FileName$, look, Spac - look))
IF INSTR(SourceName$, ".") = 0 THEN SourceName$ = SourceName$ + ".BAS"
'~~~~~ Are we using a List file (.LST)?
SELECT CASE MID$(FileName$, INSTR(FileName$, ".") + 1)
CASE "LST"
'~~~~~ Read the routine names into array (Procs)
CheckName FileName$
OPEN FileName$ FOR INPUT AS #1
Blank$ = SPACE$(ProcLen2)
DO UNTIL EOF(1)
Subs = Subs + 1
IF Subs > MaxProcs THEN FatalErr "Too many procedures!"
LINE INPUT #1, Procs(Subs).ProcName
IF Procs(Subs).ProcName = Blank$ THEN
Subs = Subs - 1
ELSE
Procs(Subs).ProcName = UCASE$(Procs(Subs).ProcName)
END IF
LOOP
CLOSE #1
CASE "OBJ"
OtherObjName$ = OtherObjName$ + " " + FileName$
CASE ELSE
'~~~~~ Search source files for external references
ReadSource SourceName$, Procs(), Subs
END SELECT
look = Spac + 1
LOOP UNTIL Spac = QPLen%(FileName$) + 1
'~~~~~ Bail out if no external routines found.
IF Subs = 0 THEN FatalErr "No external routines required."
'~~~~~ Sort the procedure names
SortT Procs(1), Subs, 0, ProcLen2 * 2 + 4, 0, ProcLen2
'~~~~~ Create the object and list files
MakeObj Subs, Procs(), LstFile$
'~~~~~ Display status message
LOCATE , 1
QPrint0 SPACE$(78), -1
QPrint0 "Creating " + NewLib$, -1
'~~~~~ SHELL out to LINK.EXE to build the new Quick Library.
LINK$ = "LINK /q/noe/seg:512 " + ObjName$ + OtherObjName$ + "," + NewLib$ + ",nul," + InpLibs$ + " " + BASLib$ + "; > LinkErr$.Tmp"
IF QPLen%(LINK$) < 127 THEN 'Check length of command line
SHELL LINK$
ELSE 'Line too long
'~~~~~ Create a LINK response file
OPEN RspName$ FOR OUTPUT AS #1
PRINT #1, "/q/noe/seg:512 " + ObjName$ + OtherObjName$ + ","
PRINT #1, NewLib$ + ",nul,"
PRINT #1, LibDir$ + InpLibs$ + "+"
PRINT #1, LibDir$ + BASLib$ + ";"
CLOSE #1
SHELL "LINK @" + RspName$ + " > LinkErr$.Tmp"
KILL RspName$
END IF
'KILL ObjName$ No, save it for use in making .LIB (DAV)
IF NOT Exist("LinkErr$.Tmp") THEN FatalErr "Cannot find [LINK.EXE]!"
'~~~~~ Check for LIB.EXE errors (OBJects not found)
LOCATE , 1
LinkErr = 0
OPEN "LinkErr$.Tmp" FOR INPUT AS #1 'Open LIB.EXE message file
DO UNTIL EOF(1)
LINE INPUT #1, Text$ 'Read a line
'Was there an error?
IF INSTR(Text$, "error") OR INSTR(UCASE$(Text$), "MEMORY") THEN
BEEP 'Yes, display the message
LinkErr = -1
LOCATE , 1
PRINT SPACE$(79)
PRINT Text$
DO UNTIL EOF(1)
LINE INPUT #1, Text$
PRINT Text$
LOOP
END IF
LOOP 'Look for more
CLOSE #1
KILL "LinkErr$.Tmp"
'~~~~~ Display status message
IF NOT LinkErr THEN
QPrint0 SPACE$(78), -1
PRINT
PRINT NewLib$; " Created."
END IF
'~~~~~ Data used by "MakeObj" to create Object file header and footer.
DATA 128,14,0,12,99,104,114,105,115,109,97,121,46,65,83,77,247,150,39
DATA 0,0,6,68,71,82,79,85,80,13,67,72,82,73,83,77,65,89,95,84,69,88,84
DATA 4,68,65,84,65,4,67,79,68,69,5,95,68,65,84,65,160,152,7,0,72,0
DATA 0,3,5,1,16,152,7,0,72,0,0,6,4,1,14,154,4,0,2,255,2,95
DATA 136,4,0,0,162,1,209,138,2,0,0,116
'~~~~~ Check File Name for validity
SUB CheckName (FileName$) STATIC
IF NOT Valid%(FileName$) THEN
FatalErr "`" + FileName$ + "' is not a valid file name!"
END IF
END SUB
'~~~~~ Displays error message and ends the program
SUB FatalErr (Message$) STATIC
BEEP
PRINT
QPrint0 Message$ + " Program terminated.", -1
PRINT
END
END SUB
'~~~~~ Get Input Parameters from User
SUB GetParms (FileName$, NewLib$, LstFile$, InpLibs$, BASLib$) STATIC
FileName$ = ".BAS"
InpLibs$ = "PRO7.LIB"
BASLib$ = BQLB$
NoSemi = 5
'~~~~~ Get command line parameters from COMMAND$
IF QPLen%(COMMAND$) THEN
Param = 1
P = 1
CMD$ = COMMAND$
'~~~~~ Check for a response file... allows use of "+" for continuation
' of lines.
Rsp = INSTR(CMD$, "@")
IF Rsp THEN
L = LEN(CMD$)
Rsp$ = ""
I = Rsp + 1
DO WHILE MID$(CMD$, I, 1) <> " "
Rsp$ = Rsp$ + MID$(CMD$, I, 1)
IF I = L THEN EXIT DO ELSE I = I + 1
LOOP
ResFx = FREEFILE
OPEN "i", ResFx, Rsp$
CMD$ = ""
WHILE NOT EOF(ResFx)
LINE INPUT #ResFx, ICmd$
IF MID$(ICmd$, QPLen(ICmd$), 1) = "+" THEN MID$(ICmd$, QPLen(ICmd$), 1) = " "
CMD$ = CMD$ + ICmd$
WEND
ICmd$ = ""
CLOSE ResFx
END IF
DO
'~~~~~ Parse out parameter looking for [,] or [;] or EOL
PC = INSTR(P, CMD$, ",")
IF PC = 0 THEN PC = INSTR(P, CMD$, ";")
IF PC = 0 THEN PC = QPLen%(CMD$) + 1
Temp$ = UCASE$(LTRIM$(RTRIM$(MID$(CMD$, P, PC - P))))
'~~~~~ Assign parameters
SELECT CASE Param
CASE 1 'File Name
FileName$ = Temp$
IF FileName$ = "" THEN FatalErr "No Source File Name!"
BaseName$ = NoXtn$(FileName$)
IF BaseName$ = FileName$ THEN FileName$ = FileName$ + ext$
NoSemi = 4
CASE 2 'New Quick Library name
NewLib$ = Temp$
NoSemi = 3
CASE 3 'List file name
LstFile$ = Temp$
NoSemi = 2
CASE 4 'Input Library names
InpLibs$ = Temp$
NoSemi = 1
CASE 5 'BASIC library name
BASLib$ = Temp$
NoSemi = 0
CASE ELSE
END SELECT
Param = Param + 1 'Bump parameter number
P = PC + 1
LOOP UNTIL PC >= QPLen%(CMD$) OR MID$(CMD$, PC, 1) = ";" 'Get another
END IF
'~~~~~ Prompt User for parameters
IF INSTR(COMMAND$, ";") = 0 THEN 'No semicolon, prompt User
IF NoSemi = 5 THEN GOSUB GetSource
IF NoSemi >= 4 THEN GOSUB GetNewLib
IF NoSemi >= 3 THEN GOSUB GetListFile
IF NoSemi >= 2 THEN GOSUB GetInputLibs
IF NoSemi >= 1 THEN GOSUB GetBQLBLib
PRINT
END IF
'~~~~~ Make default names for parameters if required
IF QPLen%(NewLib$) = 0 THEN NewLib$ = NoPath$(BaseName$) + ".QLB"
IF INSTR(NewLib$, ".") = 0 THEN NewLib$ = NewLib$ + ".QLB"
CheckName NewLib$
IF QPLen%(LstFile$) = 0 THEN LstFile$ = NoPath$(BaseName$) + ".LST"
IF INSTR(LstFile$, ".") = 0 THEN LstFile$ = LstFile$ + ".LST"
CheckName LstFile$
IF QPLen%(InpLibs$) = 0 THEN InpLibs$ = "PRO.LIB"
IF QPLen%(BASLib$) = 0 THEN BASLib$ = BQLB$
IF INSTR(BASLib$, ".") = 0 THEN BASLib$ = BASLib$ + ".LIB"
CheckName BASLib$
'~~~~~ Search for required libraries using "LIB" environment variables
LibPaths$ = ENVIRON$("LIB")
P = 1
DO 'Parse out individual names
PC = INSTR(P, InpLibs$, " ")
IF PC = 0 THEN PC = QPLen%(InpLibs$) + 1
InpLib$ = LTRIM$(RTRIM$(MID$(InpLibs$, P, PC - P)))
IF INSTR(InpLib$, ".") = 0 THEN InpLib$ = InpLib$ + ".LIB"
CheckName InpLib$
SrchPath InpLib$, LibPaths$, NotFound 'Check path for file
IF NotFound THEN FatalErr InpLib$ + " not found!"
P = PC + Blanks(MID$(InpLibs$, PC))
LOOP UNTIL P > LEN(InpLibs$)
SrchPath BASLib$, LibPaths$, NotFound 'Check paths for BASIC library
IF NotFound THEN FatalErr BASLib$ + " not found!"
EXIT SUB
'~~~~~ Get Source file name
GetSource:
FileName$ = UserInp$(NoSemi, "Main Module Name", FileName$)
IF FileName$ = ".BAS" THEN END 'Check validity
BaseName$ = NoXtn$(FileName$)
IF BaseName$ = FileName$ THEN FileName$ = FileName$ + ext$
RETURN
'~~~~~ Get output library name
GetNewLib:
IF QPLen%(NewLib$) THEN
Default$ = NewLib$
ELSE
Default$ = NoPath$(BaseName$) + ".QLB"
END IF
NewLib$ = UserInp$(NoSemi, "Output Library Name", Default$)
RETURN
'~~~~~ Get list file name
GetListFile:
IF QPLen%(LstFile$) THEN
Default$ = LstFile$
ELSE
Default$ = NoPath$(BaseName$) + ".LST"
END IF
LstFile$ = UserInp$(NoSemi, "List File Name", Default$)
RETURN
'~~~~~ Get input library names
GetInputLibs:
InpLibs$ = UserInp$(NoSemi, "Input Libraries", InpLibs$)
RETURN
'~~~~~ Get BASIC library [BQLB] name
GetBQLBLib:
BASLib$ = UserInp$(NoSemi, "BQLB## Library Name", BASLib$)
RETURN
END SUB
'~~~~~ Create an Object file consisting of EXTRN declarations
'~~~~~ Also writes the List File
SUB MakeObj (Subs, Procs() AS ProcInfo, LstFile$) STATIC
LOCATE , 1
QPrint0 "Creating temporary file: `External.obj'.", -1
'~~~~~ Create files
IF Exist%(ObjName$) THEN KILL ObjName$
OPEN ObjName$ FOR BINARY AS #1
OPEN LstFile$ FOR OUTPUT AS #2
'~~~~~ Compose OBJ Header string
a$ = SPACE$(86)
FOR I = 1 TO 86
READ B
MID$(a$, I) = CHR$(B)
NEXT
PUT #1, , a$
'~~~~~ Compose external procedure names into OBJ form
I = 1 'initial value
DO
Count = 0
FileList$ = ""
FOR N = I TO Subs 'For each procedure name
IF Procs(N).BasFlag = 0 THEN 'If it's an external proc.
'print name to list file
IF NOT Null%(Procs(N).AliasName) THEN
Temp$ = RTRIM$(Procs(N).AliasName)
ELSE
Temp$ = RTRIM$(Procs(N).ProcName)
END IF
PRINT #2, Temp$
L = QPLen%(Temp$)
Count = Count + L + 2
IF Count > 1018 THEN EXIT FOR
FileList$ = FileList$ + CHR$(L) + Temp$ + CHR$(0)
ELSE
END IF
NEXT
Lng = QPLen%(FileList$) + 1
FileList$ = CHR$(140) + CHR$(Lng MOD 256) + CHR$(Lng \ 256) + FileList$
FileList$ = FileList$ + CHR$(CheckSum(FileList$))
PUT #1, , FileList$
I = N
LOOP WHILE I <= Subs
'~~~~~ Compose OBJ Footer
a$ = SPACE$(12)
FOR I = 1 TO 12
READ B
MID$(a$, I) = CHR$(B)
NEXT
PUT #1, , a$
CLOSE #1, #2
END SUB
FUNCTION NoPath$ (FileName$) STATIC
Test$ = ":\"
FOR N = QPLen(FileName$) TO 1 STEP -1
IF INSTR(Test$, MID$(FileName$, N, 1)) THEN EXIT FOR
NEXT
NoPath$ = MID$(FileName$, N + 1)
END FUNCTION
'~~~~~ Returns the base part of a file name
FUNCTION NoXtn$ (FileName$) STATIC
Per = INSTR(FileName$, ".")
Spac = INSTR(FileName$, " ")
IF Spac = 0 THEN Spac = QPLen%(FileName$) + 1
IF Per > 0 AND Per < Spac THEN
NoXtn$ = LEFT$(FileName$, Per - 1)
ELSE
NoXtn$ = LEFT$(FileName$, Spac - 1)
END IF
END FUNCTION
'~~~~~ Read Source files looking for external routines and dead code
SUB ReadSource (FileName$, Procs() AS ProcInfo, Subs) STATIC
RtnTerm$ = " -)(%!#&@$:" + CHR$(9) 'Terminators for SUB/FUNCTION names
FastLoadSave$ = CHR$(252) + CHR$(19)
REDIM KWord$(3) 'Keyword table for finding procedures
KWord$(0) = "FUNCTION "
KWord$(1) = "SUB "
KWord$(2) = "CALL "
KWord$(3) = "CALLS "
CheckName FileName$
'~~~~~ Parse out file's path name
Path$ = LEFT$(FileName$, INSTR(FileName$, NoPath$(FileName$)) - 1)
'~~~~~ Load up the .MAK file if there is one.
MakeName$ = NoXtn$(FileName$) + ".MAK"
IF Exist%(MakeName$) THEN
OPEN MakeName$ FOR INPUT AS #1
Modules = 0 'Count the number of modules
DO UNTIL EOF(1)
LINE INPUT #1, Text$
IF QPLen%(LTRIM$(Text$)) THEN Modules = Modules + 1
LOOP
CLOSE #1
REDIM Make$(Modules) 'Make array for module names
OPEN MakeName$ FOR INPUT AS #1
FOR M = 1 TO Modules 'Read the module names
LINE INPUT #1, Make$(M)
IF QPLen%(Make$(M)) THEN
'Add a path name if needed
IF INSTR(Make$(M), "\") = 0 AND INSTR(Make$(M), ":") = 0 THEN
Make$(M) = Path$ + Make$(M)
END IF
IF INSTR(Make$(M), ".") = 0 THEN Make$(M) = Make$(M) + ".BAS"
IF NOT Exist%(Make$(M)) THEN FatalErr Make$(M) + " not found!"
ELSE
M = M - 1
END IF
NEXT
CLOSE #1
ELSE 'One module
Modules = 1
REDIM Make$(1)
Make$(1) = FileName$
END IF
'See if we have enough memory
IF FRE(-1) < ((MaxProcs + 1) * Modules * CLNG(ProcLen + 2)) + 1028& THEN
FatalErr "Not enough memory (too many modules)!"
END IF
'Array for module level procs.
REDIM ModSub(MaxProcs, 1 TO Modules) AS ModProcs
Rtn$ = SPACE$(ProcLen2) 'Work space for proc. names
'~~~~~ Search All Files for Procedure Names
LOCATE , 1
QPrint0 "Examining ", -1
LOCATE , 11
FOR M = 1 TO Modules 'Examine each module
Handle = 1 'File handle for module
IF NOT Exist%(Make$(M)) THEN FatalErr "Cannot find " + Make$(M) + "!"
OPEN Make$(M) FOR INPUT AS #Handle 'Open the module
QPrint0 SPACE$(68), -1
QPrint0 Make$(M), -1
'~~~~~ Read until end of module
DO UNTIL Handle = 1 AND EOF(1)
DO WHILE EOF(Handle) 'Close include file when done
CLOSE #Handle
Handle = Handle - 1
IF Handle = 1 THEN 'Redisplay module name
QPrint0 SPACE$(68), -1
QPrint0 Make$(M), -1
EXIT DO
END IF
LOOP
IF Handle = 1 AND EOF(1) THEN EXIT DO
Ky$ = INKEY$ 'Check for Ctrl C
IF QPLen%(Ky$) THEN
IF ASC(Ky$) = 3 THEN FatalErr ""
END IF
LINE INPUT #Handle, Text$ 'Read a line of text
Text$ = UCASE$(Text$) 'Make it upper case
'Test for binary file (Fast
' Load and Save)
IF INSTR(Text$, FastLoadSave$) THEN
FatalErr "Cannot process QuickBASIC - Fast Load and Save files!"
END IF
Length = INSTR(Text$, "'") - 1 'Get Length without comments
IF Length = -1 THEN Length = INSTR(Text$, "REM ") - 1
IF Length = -1 THEN Length = QPLen%(Text$)
'~~~~~ Look for INCLUDE files
Inc = INSTR(Text$, "$INCLUDE:")
IF Inc THEN
IF INSTR(Length + 2, Text$, "'") > Inc THEN
Inc = INSTR(Inc, Text$, "'") + 1
Inc2 = INSTR(Inc, Text$, "'")
IF Inc2 > Inc THEN
IncName$ = MID$(Text$, Inc, Inc2 - Inc)
IF INSTR(IncName$, ".") = 0 THEN IncName$ = IncName$ + ".BAS"
'Add path to include name
IF QPLen%(Path$) AND INSTR(IncName$, "\") = 0 AND INSTR(IncName$, ":") = 0 THEN
IncName$ = Path$ + IncName$
END IF
IF NOT Exist%(IncName$) THEN
IncName$ = MID$(IncName$, QPLen%(Path$) + 1)
'Check envirnment path
SrchPath IncName$, ENVIRON$("INCLUDE"), NotFound
IF NotFound THEN FatalErr "Include file " + IncName$ + " not found!"
END IF
Handle = Handle + 1 'Bump handle
OPEN IncName$ FOR INPUT AS #Handle 'Open the include file
QPrint0 SPACE$(68), -1 'Display the name of INCLUDE
QPrint0 "Include File: " + IncName$, -1
Length = 0
END IF
END IF
END IF
'Trim left side and remark
Text$ = LTRIM$(LEFT$(Text$, Length))
IF QPLen(Text$) THEN 'If its not a Nul string,
N = INSTR(Text$, CHR$(34)) 'Remove quoted strings
IF N THEN
IF INSTR(Text$, "ALIAS") = 0 THEN 'Except Alias name
Text$ = LEFT$(Text$, N - 1) + MID$(Text$, INSTR(N + 1, Text$, CHR$(34)) + 1)
END IF
END IF
'~~~~~ Check for each key word
FOR KW = 0 TO 3
KWPos = 1
DO
'Look for key word
KWPos = INSTR(KWPos, Text$, KWord$(KW))
IF KWPos > 1 THEN 'Make sure it's a whole word
IF INSTR(CHR$(32) + CHR$(9), MID$(Text$, KWPos - 1, 1)) = 0 THEN KWPos = 0
'IF KW < 2 THEN 'Check for valid declare
' IF INSTR(Text$, "DECLARE") <> KWPos - 8 THEN KWPos = 0
'END IF
END IF
IF KWPos THEN 'If there's a valid key word
'~~~~~ Extract the keyword from the line
'Bump pointer to end of key
KWEnd = KWPos + QPLen%(KWord$(KW))
'look for end of proc. name
FOR P2 = KWEnd + 1 TO QPLen%(Text$)
IF INSTR(RtnTerm$, MID$(Text$, P2, 1)) THEN EXIT FOR
NEXT
'Extract proceedure name
LSET Rtn$ = MID$(Text$, KWEnd, P2 - KWEnd)
'~~~~~ See if procedure used before in ANY modules
N = Subs
FindT Procs(1), ProcLen2 * 2 + 4, N, Rtn$
IF N = -1 THEN
N = Subs + 1
IF N > MaxProcs THEN FatalErr "Too many procedures!"
ELSE
N = N + 1
END IF
'~~~~~ See if procedure used before in THIS module
MS = ModSub(0, M).Count
ModSub(0, M).ProcName = Rtn$
FindT ModSub(1, M), ProcLen + 2, MS, ModSub(0, M).ProcName
IF MS = -1 THEN
MS = ModSub(0, M).Count + 1
ModSub(0, M).Count = MS 'Bump number of procedures
ModSub(MS, M).ProcName = Rtn$ 'Assign Proc. name
ELSE
MS = MS + 1
END IF
'~~~~~ If it's a "CALL" or "CALLS",
IF KW > 1 THEN 'Bump count for routine
ModSub(MS, M).Count = ModSub(MS, M).Count + 1
Procs(N).Refed = 2
END IF
'~~~~~ Is this a BASIC proc. definition (SUB/FUNCTION)?
IF KW < 2 THEN 'AND KWPos = 1 THEN
IF INSTR(Text$, "DECLARE") <> KWPos - 8 THEN
Procs(N).BasFlag = BASProc 'Set flag
'If referenced befor, set flag
IF Procs(N).Refed > 1 OR ModSub(MS, M).Count THEN
Procs(N).BasFlag = RefedProc
END IF
END IF
END IF
'~~~~~ If its a new procedure name
IF N > Subs THEN
Procs(N).ProcName = Rtn$ 'Assign it
Subs = N 'Bump number of procedures
'Look for an ALIAS name
Al = INSTR(Text$, "ALIAS")
IF Al THEN
Al = Al + 7
AlEnd = INSTR(Al, Text$, CHR$(34))
Procs(N).AliasName = MID$(Text$, Al, AlEnd - Al)
END IF
'Is this a BASIC procedure?
ELSEIF Procs(N).BasFlag = BASProc THEN
IF Procs(N).Refed > 1 OR ModSub(MS, M).Count THEN
'Set flag to show it was
Procs(N).BasFlag = RefedProc ' referenced
END IF
END IF
'Remove Name so it isn't
' found below
Text$ = LEFT$(Text$, KWEnd - 1) + MID$(Text$, P2)
KWPos = KWPos + 1 'Bump pointer for next word
END IF
LOOP WHILE KWPos AND KW > 1 'Look for more on line
NEXT 'Check for next key word
'~~~~~ Look for references to procs. that were declared
FOR N = 1 TO ModSub(0, M).Count 'Examin text for prev. refs.
IF ModSub(N, M).Count = 0 THEN
look = 0
DO
look = INSTR(look + 1, Text$, RTRIM$(ModSub(N, M).ProcName))
IF look THEN
Start = look
IF Start > 1 THEN 'Begining of line?
'Check Begining of word
IF INSTR(RtnTerm$, MID$(Text$, Start - 1, 1)) = 0 THEN
Start = 0
END IF
END IF
IF Start THEN 'Check end of word
PrLen = QPLen%(RTRIM$(ModSub(N, M).ProcName))
IF INSTR(RtnTerm$, MID$(Text$, Start + PrLen, 1)) THEN
ModSub(N, M).Count = ModSub(N, M).Count + 1
'Check for previous refs.
LSET Rtn$ = MID$(Text$, Start, PrLen)
P = Subs
FindT Procs(1), ProcLen2 * 2 + 4, P, Rtn$
IF P > -1 THEN
P = P + 1
'Is it a BASIC procedure?
IF Procs(P).BasFlag THEN
'~~~~~ Check for function assignment
IF MID$(Text$, Start + PrLen + 1, 1) = "=" THEN
'Decrement counter
ModSub(N, M).Count = ModSub(N, M).Count - 1
ELSE 'Show it was referenced
Procs(P).Refed = 2
END IF
ELSE 'Show it was referenced
Procs(P).Refed = 2
END IF
END IF
END IF
END IF
END IF
LOOP WHILE look
END IF
NEXT
END IF
LOOP 'Read another line of text
CLOSE #1 'Close the module
NEXT 'Read the next module file
ERASE KWord$ 'Clean up string space
Text$ = ""
LOCATE , 1
QPrint0 SPACE$(78), -1 'Erase message from screen
'~~~~~ Display unreferenced routines
NoTitle = -1
FOR M = 1 TO Modules 'For each module
R = FREEFILE 'DAV added this feature so
UMake$ = LEFT$(Make$(M), LEN(Make$(M)) - 4) + ".UNR" 'unreferenced
OPEN UMake$ FOR OUTPUT AS #R 'items will be saved
NoModName = -1
FOR N = 1 TO ModSub(0, M).Count 'For each procedure in module
IF ModSub(N, M).Count = 0 THEN 'Count of 0 means wasn't used
'Look in master list
P = Subs
FindT Procs(1), ProcLen2 * 2 + 4, P, ModSub(N, M).ProcName
P = P + 1
'Confirm lack of reference
IF Procs(P).BasFlag <> RefedProc AND Procs(P).Refed <> 2 THEN
IF NoTitle THEN 'Print error message
PRINT
Msg$ = "Note: The following procedures have been declared or defined but never used."
PRINT Msg$: PRINT #R, Msg$
NoTitle = 0
END IF
IF NoModName THEN 'Print Module name
Msg$ = Make$(M)
PRINT Msg$: PRINT #R, Msg$
NoModName = 0
END IF
'Print procedure name
PRINT TAB(4); ModSub(N, M).ProcName;
PRINT #R, TAB(4); ModSub(N, M).ProcName;
IF Procs(P).BasFlag = BASProc THEN 'Print message
Msg$ = " is an unused BASIC procedure."
PRINT Msg$: PRINT #R, Msg$
ELSE
Msg$ = " was DECLAREd but not used"
PRINT Msg$; : PRINT #R, Msg$;
IF Procs(P).Refed <> 2 THEN
Msg$ = "."
PRINT Msg$: PRINT #R, Msg$
Procs(P).BasFlag = 1
ELSE
Msg$ = " in this module."
PRINT Msg$: PRINT #R, Msg$
Procs(P).BasFlag = 0
END IF
END IF
END IF
END IF
NEXT
CLOSE #R
NEXT
ERASE ModSub, Make$
Rtn$ = "": Msg$ = "": UMake$ = ""
END SUB
'~~~~~ Search an environment path for a file
SUB SrchPath (FileName$, Paths$, NotFound) STATIC
NotFound = -1 'Guilty until proven otherwise
Path$ = "" 'No Path yet
PP = 1 'Present position
DO UNTIL Exist(Path$ + FileName$) 'Loop until we find the file
IF PP > QPLen%(Paths$) THEN EXIT SUB 'Bail out if no more paths
PCP = INSTR(PP, Paths$, ";") 'Find Semicolon position
IF PCP = 0 THEN PCP = QPLen%(Paths$) + 1 'Last path
'Parse out the path
Path$ = LTRIM$(RTRIM$(MID$(Paths$, PP, PCP - PP)))
'Ensure there's a "\" at end
IF RIGHT$(Path$, 1) <> "\" THEN Path$ = Path$ + "\"
'Bump position for next path
PP = PCP + 1
LOOP
FileName$ = Path$ + FileName$ 'Add the path to the file name
NotFound = 0
END SUB
'~~~~~ Prompt User for input
FUNCTION UserInp$ (NoSemi, Prompt$, Default$) STATIC
PRINT Prompt$; " ["; Default$; "]: ";
LINE INPUT ""; Temp$
Temp$ = UCASE$(LTRIM$(RTRIM$(Temp$)))
IF RIGHT$(Temp$, 1) = ";" THEN
Temp$ = LEFT$(Temp$, QPLen(Temp$) - 1)
NoSemi = 0
END IF
IF QPLen%(Temp$) = 0 THEN Temp$ = Default$
UserInp$ = Temp$
END FUNCTION